home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / port.scm < prev    next >
Text File  |  1995-10-13  |  2KB  |  81 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; Current input and output ports.
  4.  
  5. (define $current-input-port  (make-fluid #f))
  6. (define $current-output-port (make-fluid #f))
  7. (define $error-output-port   (make-fluid #f))
  8.  
  9. (define (current-input-port)
  10.   (fluid $current-input-port))
  11.  
  12. (define (current-output-port)
  13.   (fluid $current-output-port))
  14.  
  15. (define (error-output-port)
  16.   (fluid $error-output-port))
  17.  
  18. (define (with-initial-ports in out thunk)
  19.   (let-fluids $current-input-port in
  20.           $current-output-port out
  21.           $error-output-port out
  22.     thunk))
  23.  
  24.  
  25. ; File openers with unwind protection
  26.  
  27. (define (call-with-mumble-file open close)
  28.   (lambda (string proc)
  29.     (let ((port #f))
  30.       (dynamic-wind (lambda ()
  31.               (if port
  32.               (warn "throwing back into a call-with-...put-file"
  33.                 string)
  34.               (set! port (open string))))
  35.             (lambda () (proc port))
  36.             (lambda ()
  37.               (if port
  38.               (close port)))))))
  39.  
  40. (define call-with-input-file
  41.   (call-with-mumble-file open-input-file close-input-port))
  42.  
  43. (define call-with-output-file
  44.   (call-with-mumble-file open-output-file close-output-port))
  45.  
  46. ;(define (call-with-input-file string proc)
  47. ;  (let* ((port (open-input-file string))
  48. ;         (result (proc port)))
  49. ;    (close-input-port port)
  50. ;    result))
  51. ;
  52. ;(define (call-with-output-file string proc)
  53. ;  (let* ((port (open-output-file string))
  54. ;         (result (proc port)))
  55. ;    (close-output-port port)
  56. ;    result))
  57.  
  58. (define (with-input-from-file string thunk)
  59.   (call-with-input-file string
  60.     (lambda (port)
  61.       (let-fluid $current-input-port port thunk))))
  62.  
  63. (define (with-output-to-file string thunk)
  64.   (call-with-output-file string
  65.     (lambda (port)
  66.       (let-fluid $current-output-port port thunk))))
  67.  
  68. (define (newline . port-option)
  69.   (write-char #\newline (output-port-option port-option)))
  70.  
  71.  
  72. (define (output-port-option port-option)
  73.   (cond ((null? port-option) (current-output-port))
  74.     ((null? (cdr port-option)) (car port-option))
  75.     (else (error "write-mumble: too many arguments" port-option))))
  76.  
  77. (define (input-port-option port-option)
  78.   (cond ((null? port-option) (current-input-port))
  79.     ((null? (cdr port-option)) (car port-option))
  80.     (else (error "read-mumble: too many arguments" port-option))))
  81.